home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / CHAR.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  3.2 KB  |  95 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; character functions
  3.  
  4. (provide 'character)
  5.  
  6. (defconstant *ascii-a* (char-int #\a))
  7. (defconstant *ascii-upper-a* (char-int #\A))
  8. (defconstant *ascii-z* (char-int #\z))
  9. (defconstant *ascii-upper-z* (char-int #\Z))
  10. (defconstant *ascii-0* (char-int #\0))
  11. (defconstant *ascii-9* (char-int #\9))
  12. (defconstant *ascii-space* (char-int #\space))
  13. (defconstant *ascii-delete* 127)
  14.  
  15. (defconstant *shift-bit* 32)
  16. (defconstant *control-bit* 64)
  17. (defconstant *not-shift-bit* (lognot *shift-bit*))
  18. (defconstant *not-control-bit* (lognot *shift-bit*))
  19. (defconstant *not-control-shift-bits*
  20.   (lognot (logior *shift-bit* *control-bit*)))
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ; turn-on-character-shift-bit 
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. (defun turn-on-character-shift-bit (c)
  27.   (int-char (logior (char-int c) *shift-bit*)))
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ; turn-on-character-control-bit 
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32.  
  33. (defun turn-on-character-control-bit (c)
  34.   (int-char (logior (char-int c) *control-bit*)))
  35.  
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ; turn-off-character-shift-bit 
  38. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39.  
  40. (defun turn-off-character-shift-bit (c)
  41.   (int-char (logand (char-int c) *not-shift-bit*)))
  42.  
  43. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44. ; turn-off-character-control-bit 
  45. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46.  
  47. (defun turn-off-character-control-bit (c)
  48.   (int-char (logand (char-int c) *not-control-bit*)))
  49.   
  50. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51. ; turn-off-character-shift-and-control-bits 
  52. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53.  
  54. (defun turn-off-character-shift-and-control-bits (c)
  55.   (int-char (logand (char-int c) *not-shift-control-bits*)))
  56.  
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58. ; alpha-char-p 
  59. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60.  
  61. (defun alpha-char-p (c)
  62.   (let ((n (char-int c)))
  63.     (or (<= *ascii-a* n *ascii-z*)
  64.         (<= *ascii-upper-a* n *ascii-upper-z*))))
  65.  
  66. ; Now provided by XLISP 2.0
  67. ;(defun digit-char-p (c)
  68. ;  (let ((n (char-int c)))
  69. ;    (<= *ascii-0* n *ascii-9*)))
  70.  
  71. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72. ; alphanumericp 
  73. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74.  
  75. (defun alphanumericp (c)
  76.   (let ((n (char-int c)))
  77.     (or (<= *ascii-a* n *ascii-z*)
  78.         (<= *ascii-upper-a* n *ascii-upper-z*)
  79.         (<= *ascii-0* n *ascii-9*))))
  80.  
  81. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82. ; whitespacep 
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84.  
  85. (defun whitespacep (char)
  86.   (equal (aref *readtable* (char-int char)) :white-space))
  87.  
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89. ; graphic-char-p 
  90. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91.  
  92. (defun graphic-char-p (c)
  93.   (let ((n (char-int c)))
  94.     (< *ascii-space* n *ascii-delete*)))
  95.